-- Test case constributed by Till Theis
module Tests.DataToTag where
import Control.Monad
import System.IO.Unsafe
import Control.Applicative (Applicative (..))

trace :: Show a => a -> b -> b
trace msg = seq $! unsafePerformIO (putStrLn $ show msg)

runTest :: IO String
runTest = return . show $ parse "a"

-- | Parse a string into the token list [Tok1] and return True if the parser
-- (token Tok1) can verify that.
parse :: String -> Bool
parse s =
  case runParser tokenize s of
       Just ([], ts) -> case runParser (token Tok1) ts of
                             Just ([], _)   -> True
                             _ -> False
       _ -> False


-- | The Parser type is parameterized over the input stream element type @s@ and
-- the return type @a@. A parser takes the input and produces a return value
-- together with the not yet consumed input.
newtype Parser s a = Parser { runParser :: [s] -> Maybe ([s], a) }

parserError s msg = Nothing
parserAccept s a = Just (s, a)

instance Functor (Parser s) where
  fmap f m = m >>= return . f

instance Applicative (Parser s) where
  pure = return
  f <*> x = f >>= \f' -> fmap f' x

instance Monad (Parser s) where
  p >>= f = Parser $ \s ->
    case runParser p s of
      Just (s', a) -> runParser (f a) s'
      Nothing -> Nothing

  return = Parser . flip parserAccept
  fail = Parser . flip parserError


(<|>) :: Parser s a -> Parser s a -> Parser s a
p1 <|> p2 = Parser $ \s -> runParser p1 s `or` runParser p2 s
  where Nothing `or` b = b
        a `or` _ = a


many :: Parser s a -> Parser s [a]
many p = many1 p <|> return []

many1 :: Parser s a -> Parser s [a]
many1 p = liftM2 (:) p (many p)

satisfy :: (s -> Bool) -> Parser s s
satisfy p = Parser go
  where go (x:xs) | p x = parserAccept xs x
        go s = parserError s "not satisfied"



data Token = Tok1 | Tok2 | Tok3 | Tok4 | Tok5 | Tok6 | Tok7 | Tok8 | Tok9 deriving (Show, Eq)

tokenize :: Parser Char [Token]
tokenize = many1 $ many1 (satisfy $ const True) >> return Tok1


token :: Token -> Parser Token Token
token t = satisfy (== t)
